home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / lib / perl5 / Moose / Util.pm < prev   
Encoding:
Perl POD Document  |  2010-07-25  |  11.1 KB  |  445 lines

  1. package Moose::Util;
  2.  
  3. use strict;
  4. use warnings;
  5.  
  6. use Data::OptList;
  7. use Sub::Exporter;
  8. use Scalar::Util 'blessed';
  9. use Class::MOP   0.60;
  10.  
  11. our $VERSION   = '1.09';
  12. $VERSION = eval $VERSION;
  13. our $AUTHORITY = 'cpan:STEVAN';
  14.  
  15. my @exports = qw[
  16.     find_meta
  17.     does_role
  18.     search_class_by_role
  19.     ensure_all_roles
  20.     apply_all_roles
  21.     with_traits
  22.     get_all_init_args
  23.     get_all_attribute_values
  24.     resolve_metatrait_alias
  25.     resolve_metaclass_alias
  26.     add_method_modifier
  27.     english_list
  28.     meta_attribute_alias
  29.     meta_class_alias
  30. ];
  31.  
  32. Sub::Exporter::setup_exporter({
  33.     exports => \@exports,
  34.     groups  => { all => \@exports }
  35. });
  36.  
  37. ## some utils for the utils ...
  38.  
  39. sub find_meta { Class::MOP::class_of(@_) }
  40.  
  41. ## the functions ...
  42.  
  43. sub does_role {
  44.     my ($class_or_obj, $role) = @_;
  45.  
  46.     my $meta = find_meta($class_or_obj);
  47.  
  48.     return unless defined $meta;
  49.     return unless $meta->can('does_role');
  50.     return 1 if $meta->does_role($role);
  51.     return;
  52. }
  53.  
  54. sub search_class_by_role {
  55.     my ($class_or_obj, $role) = @_;
  56.  
  57.     my $meta = find_meta($class_or_obj);
  58.  
  59.     return unless defined $meta;
  60.  
  61.     my $role_name = blessed $role ? $role->name : $role;
  62.  
  63.     foreach my $class ($meta->class_precedence_list) {
  64.  
  65.         my $_meta = find_meta($class);
  66.  
  67.         next unless defined $_meta;
  68.  
  69.         foreach my $role (@{ $_meta->roles || [] }) {
  70.             return $class if $role->name eq $role_name;
  71.         }
  72.     }
  73.  
  74.     return;
  75. }
  76.  
  77. # this can possibly behave in unexpected ways because the roles being composed
  78. # before being applied could differ from call to call; I'm not sure if or how
  79. # to document this possible quirk.
  80. sub ensure_all_roles {
  81.     my $applicant = shift;
  82.     _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
  83. }
  84.  
  85. sub apply_all_roles {
  86.     my $applicant = shift;
  87.     _apply_all_roles($applicant, undef, @_);
  88. }
  89.  
  90. sub _apply_all_roles {
  91.     my $applicant = shift;
  92.     my $role_filter = shift;
  93.  
  94.     unless (@_) {
  95.         require Moose;
  96.         Moose->throw_error("Must specify at least one role to apply to $applicant");
  97.     }
  98.  
  99.     my $roles = Data::OptList::mkopt( [@_] );
  100.  
  101.     my @role_metas;
  102.     foreach my $role (@$roles) {
  103.         my $meta;
  104.  
  105.         if ( blessed $role->[0] ) {
  106.             $meta = $role->[0];
  107.         }
  108.         else {
  109.             Class::MOP::load_class( $role->[0] , $role->[1] );
  110.             $meta = Class::MOP::class_of( $role->[0] );
  111.         }
  112.  
  113.         unless ($meta && $meta->isa('Moose::Meta::Role') ) {
  114.             require Moose;
  115.             Moose->throw_error( "You can only consume roles, "
  116.                     . $role->[0]
  117.                     . " is not a Moose role" );
  118.         }
  119.  
  120.         push @role_metas, [ $meta, $role->[1] ];
  121.     }
  122.  
  123.     if ( defined $role_filter ) {
  124.         @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
  125.     }
  126.  
  127.     return unless @role_metas;
  128.  
  129.     my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
  130.  
  131.     if ( scalar @role_metas == 1 ) {
  132.         my ( $role, $params ) = @{ $role_metas[0] };
  133.         $role->apply( $meta, ( defined $params ? %$params : () ) );
  134.     }
  135.     else {
  136.         Moose::Meta::Role->combine(@role_metas)->apply($meta);
  137.     }
  138. }
  139.  
  140. sub with_traits {
  141.     my ($class, @roles) = @_;
  142.     return $class unless @roles;
  143.     return Moose::Meta::Class->create_anon_class(
  144.         superclasses => [$class],
  145.         roles        => \@roles,
  146.         cache        => 1,
  147.     )->name;
  148. }
  149.  
  150. # instance deconstruction ...
  151.  
  152. sub get_all_attribute_values {
  153.     my ($class, $instance) = @_;
  154.     return +{
  155.         map { $_->name => $_->get_value($instance) }
  156.             grep { $_->has_value($instance) }
  157.                 $class->get_all_attributes
  158.     };
  159. }
  160.  
  161. sub get_all_init_args {
  162.     my ($class, $instance) = @_;
  163.     return +{
  164.         map { $_->init_arg => $_->get_value($instance) }
  165.             grep { $_->has_value($instance) }
  166.                 grep { defined($_->init_arg) }
  167.                     $class->get_all_attributes
  168.     };
  169. }
  170.  
  171. sub resolve_metatrait_alias {
  172.     return resolve_metaclass_alias( @_, trait => 1 );
  173. }
  174.  
  175. sub _build_alias_package_name {
  176.     my ($type, $name, $trait) = @_;
  177.     return 'Moose::Meta::'
  178.          . $type
  179.          . '::Custom::'
  180.          . ( $trait ? 'Trait::' : '' )
  181.          . $name;
  182. }
  183.  
  184. {
  185.     my %cache;
  186.  
  187.     sub resolve_metaclass_alias {
  188.         my ( $type, $metaclass_name, %options ) = @_;
  189.  
  190.         my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
  191.         return $cache{$cache_key}{$metaclass_name}
  192.             if $cache{$cache_key}{$metaclass_name};
  193.  
  194.         my $possible_full_name = _build_alias_package_name(
  195.             $type, $metaclass_name, $options{trait}
  196.         );
  197.  
  198.         my $loaded_class = Class::MOP::load_first_existing_class(
  199.             $possible_full_name,
  200.             $metaclass_name
  201.         );
  202.  
  203.         return $cache{$cache_key}{$metaclass_name}
  204.             = $loaded_class->can('register_implementation')
  205.             ? $loaded_class->register_implementation
  206.             : $loaded_class;
  207.     }
  208. }
  209.  
  210. sub add_method_modifier {
  211.     my ( $class_or_obj, $modifier_name, $args ) = @_;
  212.     my $meta
  213.         = $class_or_obj->can('add_before_method_modifier')
  214.         ? $class_or_obj
  215.         : find_meta($class_or_obj);
  216.     my $code                = pop @{$args};
  217.     my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
  218.     if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
  219.         if ( $method_modifier_type eq 'Regexp' ) {
  220.             my @all_methods = $meta->get_all_methods;
  221.             my @matched_methods
  222.                 = grep { $_->name =~ @{$args}[0] } @all_methods;
  223.             $meta->$add_modifier_method( $_->name, $code )
  224.                 for @matched_methods;
  225.         }
  226.         elsif ($method_modifier_type eq 'ARRAY') {
  227.             $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
  228.         }
  229.         else {
  230.             $meta->throw_error(
  231.                 sprintf(
  232.                     "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
  233.                     $modifier_name,
  234.                     $method_modifier_type,
  235.                 )
  236.             );
  237.         }
  238.     }
  239.     else {
  240.         $meta->$add_modifier_method( $_, $code ) for @{$args};
  241.     }
  242. }
  243.  
  244. sub english_list {
  245.     my @items = sort @_;
  246.  
  247.     return $items[0] if @items == 1;
  248.     return "$items[0] and $items[1]" if @items == 2;
  249.  
  250.     my $tail = pop @items;
  251.     my $list = join ', ', @items;
  252.     $list .= ', and ' . $tail;
  253.  
  254.     return $list;
  255. }
  256.  
  257. sub _caller_info {
  258.     my $level = @_ ? ($_[0] + 1) : 2;
  259.     my %info;
  260.     @info{qw(package file line)} = caller($level);
  261.     return \%info;
  262. }
  263.  
  264. sub _create_alias {
  265.     my ($type, $name, $trait, $for) = @_;
  266.     my $package = _build_alias_package_name($type, $name, $trait);
  267.     Class::MOP::Class->initialize($package)->add_method(
  268.         register_implementation => sub { $for }
  269.     );
  270. }
  271.  
  272. sub meta_attribute_alias {
  273.     my ($to, $from) = @_;
  274.     $from ||= caller;
  275.     my $meta = Class::MOP::class_of($from);
  276.     my $trait = $meta->isa('Moose::Meta::Role');
  277.     _create_alias('Attribute', $to, $trait, $from);
  278. }
  279.  
  280. sub meta_class_alias {
  281.     my ($to, $from) = @_;
  282.     $from ||= caller;
  283.     my $meta = Class::MOP::class_of($from);
  284.     my $trait = $meta->isa('Moose::Meta::Role');
  285.     _create_alias('Class', $to, $trait, $from);
  286. }
  287.  
  288. 1;
  289.  
  290. __END__
  291.  
  292. =pod
  293.  
  294. =head1 NAME
  295.  
  296. Moose::Util - Utilities for working with Moose classes
  297.  
  298. =head1 SYNOPSIS
  299.  
  300.   use Moose::Util qw/find_meta does_role search_class_by_role/;
  301.  
  302.   my $meta = find_meta($object) || die "No metaclass found";
  303.  
  304.   if (does_role($object, $role)) {
  305.     print "The object can do $role!\n";
  306.   }
  307.  
  308.   my $class = search_class_by_role($object, 'FooRole');
  309.   print "Nearest class with 'FooRole' is $class\n";
  310.  
  311. =head1 DESCRIPTION
  312.  
  313. This module provides a set of utility functions. Many of these
  314. functions are intended for use in Moose itself or MooseX modules, but
  315. some of them may be useful for use in your own code.
  316.  
  317. =head1 EXPORTED FUNCTIONS
  318.  
  319. =over 4
  320.  
  321. =item B<find_meta($class_or_obj)>
  322.  
  323. This method takes a class name or object and attempts to find a
  324. metaclass for the class, if one exists. It will B<not> create one if it
  325. does not yet exist.
  326.  
  327. =item B<does_role($class_or_obj, $role_or_obj)>
  328.  
  329. Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
  330. be provided as a name or a L<Moose::Meta::Role> object.
  331.  
  332. The class must already have a metaclass for this to work. If it doesn't, this
  333. function simply returns false.
  334.  
  335. =item B<search_class_by_role($class_or_obj, $role_or_obj)>
  336.  
  337. Returns the first class in the class's precedence list that does
  338. C<$role_or_obj>, if any. The role can be either a name or a
  339. L<Moose::Meta::Role> object.
  340.  
  341. The class must already have a metaclass for this to work.
  342.  
  343. =item B<apply_all_roles($applicant, @roles)>
  344.  
  345. This function applies one or more roles to the given C<$applicant> The
  346. applicant can be a role name, class name, or object.
  347.  
  348. The C<$applicant> must already have a metaclass object.
  349.  
  350. The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
  351. each of which can be followed by an optional hash reference of options
  352. (C<-excludes> and C<-alias>).
  353.  
  354. =item B<ensure_all_roles($applicant, @roles)>
  355.  
  356. This function is similar to L</apply_all_roles>, but only applies roles that
  357. C<$applicant> does not already consume.
  358.  
  359. =item B<with_traits($class_name, @role_names)>
  360.  
  361. This function creates a new class from C<$class_name> with each of
  362. C<@role_names> applied. It returns the name of the new class.
  363.  
  364. =item B<get_all_attribute_values($meta, $instance)>
  365.  
  366. Returns a hash reference containing all of the C<$instance>'s
  367. attributes. The keys are attribute names.
  368.  
  369. =item B<get_all_init_args($meta, $instance)>
  370.  
  371. Returns a hash reference containing all of the C<init_arg> values for
  372. the instance's attributes. The values are the associated attribute
  373. values. If an attribute does not have a defined C<init_arg>, it is
  374. skipped.
  375.  
  376. This could be useful in cloning an object.
  377.  
  378. =item B<resolve_metaclass_alias($category, $name, %options)>
  379.  
  380. =item B<resolve_metatrait_alias($category, $name, %options)>
  381.  
  382. Resolves a short name to a full class name. Short names are often used
  383. when specifying the C<metaclass> or C<traits> option for an attribute:
  384.  
  385.     has foo => (
  386.         metaclass => "Bar",
  387.     );
  388.  
  389. The name resolution mechanism is covered in
  390. L<Moose/Metaclass and Trait Name Resolution>.
  391.  
  392. =item B<meta_class_alias($to[, $from])>
  393.  
  394. =item B<meta_attribute_alias($to[, $from])>
  395.  
  396. Create an alias from the class C<$from> (or the current package, if
  397. C<$from> is unspecified), so that
  398. L<Moose/Metaclass and Trait Name Resolution> works properly.
  399.  
  400. =item B<english_list(@items)>
  401.  
  402. Given a list of scalars, turns them into a proper list in English
  403. ("one and two", "one, two, three, and four"). This is used to help us
  404. make nicer error messages.
  405.  
  406. =back
  407.  
  408. =head1 TODO
  409.  
  410. Here is a list of possible functions to write
  411.  
  412. =over 4
  413.  
  414. =item discovering original method from modified method
  415.  
  416. =item search for origin class of a method or attribute
  417.  
  418. =back
  419.  
  420. =head1 BUGS
  421.  
  422. See L<Moose/BUGS> for details on reporting bugs.
  423.  
  424. =head1 AUTHOR
  425.  
  426. Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
  427.  
  428. B<with contributions from:>
  429.  
  430. Robert (phaylon) Sedlacek
  431.  
  432. Stevan Little
  433.  
  434. =head1 COPYRIGHT AND LICENSE
  435.  
  436. Copyright 2007-2009 by Infinity Interactive, Inc.
  437.  
  438. L<http://www.iinteractive.com>
  439.  
  440. This library is free software; you can redistribute it and/or modify
  441. it under the same terms as Perl itself.
  442.  
  443. =cut
  444.  
  445.